#lang scheme

(provide string->punycode ; punycode is bstr
         punycode->string
         ;domain->unicode ; domain is bstr
         ;unicode->domain
         )

(require "test.ss"
         srfi/71 ; let-values replacer
         srfi/67 ; if3
         "bytes.ss")


#|
;; bytes -> string
(define (punycode->string-ref bstr)
  (let ([blen (bytes-length bstr)]
        [split-pos (bytes-index-right bstr (char->integer #\-))])
    ; TODO: 1 loop?
    (let bigloop ([in (if split-pos (+ 1 split-pos) 0)]
                  [bias 72] ; initial_bias
                  [str (if split-pos (bytes->string/latin-1 (subbytes bstr 0 split-pos)) "")]
                  [last-ch 128]
                  [last-pt 0]) 
      (let ([in i (let loop ([in in] [ix last-pt] [k 36] [w 1])
                    (let* ([digit (b->i (bytes-ref bstr in))]
                           [t (min (max (- k bias) 1) 26)] ; (bound (- k bias) tmin tmax)
                           [i (+ ix (* digit w))])
                      (if (< digit t)
                          (values (+ 1 in) i)
                          (loop (+ 1 in) i (+ 36 k) (* w (- 36 t))))))])
        (let* ([npoints (+ 1 (string-length str))]
               [new-ch (+ last-ch (quotient i npoints))]
               [new-pt (remainder i npoints)]
               [new-str (string-append
                         (substring str 0 new-pt)
                         (string (integer->char new-ch))
                         (substring str new-pt))])
          (if (< in blen)
              (bigloop in
                       (adapt (- i last-pt) npoints (zero? last-pt))
                       new-str
                       new-ch
                       (+ 1 new-pt))
              new-str))))))
|#


;; number -> fxnum -> boolean -> fxnum
(define (adapt delta numpoints firsttime)
  (let* ([delta (quotient delta (if firsttime 700 2))]
         [delta (+ delta (quotient delta numpoints))])
    (let loop ([delta delta] [k 0])
      (if (> delta 455) 
          (loop (quotient delta 35) (+ k 36))
          (+ k (quotient (* 36 delta) (+ delta 38)))))))
;    (cond [(<= delta 455) 
;           (+ 0 (quotient (* 36 delta) (+ delta 38)))]
;          [(<= delta 15925)
;           (let ([delta (quotient delta 35)])
;             (+ 36 (quotient (* 36 delta) (+ delta 38))))]
;          [(<= delta 557375)
;           (let ([delta (quotient delta 1225)])
;             (+ 72 (quotient (* 36 delta) (+ delta 38))))]
;          [(<= delta 19508125)
;           (let ([delta (quotient delta 42875)])
;             (+ 108 (quotient (* 36 delta) (+ delta 38))))]
;          [else (error "overflow" delta)])))

;(=! 21 (adapt 19899 1 #t))
;(=! 53 (adapt 1643 2 #f))
;(=! 81 (adapt 27414 3 #f))
;(=! 66 (adapt 10777 4 #f))

;; bytes -> string
(define (punycode->string bstr)
  ;; byte -> byte
  (define (b->i b)
    (cond
      [(byte-upper-case? b) (- b (char->integer #\A))]
      [(byte-lower-case? b) (- b (char->integer #\a))]
      [(byte-numeric? b) (+ 26 (- b (char->integer #\0)))]
      [else (error "b->i" b)]))
  
  (let ([blen (bytes-length bstr)]
        [split-pos (bytes-index-right bstr (char->integer #\-))])
    (if (zero? blen)
        ""
        (let loop ([in (if split-pos (+ 1 split-pos) 0)] 
                   [bias 72]
                   [str (if split-pos (bytes->string/latin-1 (subbytes bstr 0 split-pos)) "")]
                   [last-ch 128] [last-pt 0] [ix 0] [k 36] [w 1])
          (let* ([digit (b->i (bytes-ref bstr in))]
                 [in (+ 1 in)]
                 [t (min (max (- k bias) 1) 26)] ; (bound (- k bias) tmin tmax)
                 [i (+ ix (* digit w))])
            (if (>= digit t)
                (loop in bias str last-ch last-pt i (+ 36 k) (* w (- 36 t)))
                (let* ([npoints (+ 1 (string-length str))]
                       [new-ch (+ last-ch (quotient i npoints))]
                       [new-pt (remainder i npoints)]
                       [new-str (string-append (substring str 0 new-pt)
                                               (string (integer->char new-ch))
                                               (substring str new-pt))])
                  (if (< in blen)
                      (loop in (adapt (- i last-pt) npoints (zero? last-pt))
                            new-str new-ch (+ 1 new-pt) (+ 1 new-pt) 36 1)
                      new-str))))))))

;; string -> bytes
; TODO: caseflags?
(define (string->punycode str)
  (define (i->b i)
    (bytes-ref #"abcdefghijklmnopqrstuvwxyz0123456789" i))
  (define maxint #x200000)
  (let* ([slist (map char->integer (string->list str))]
         [basic (apply bytes (filter (lambda (i) (< i 128)) slist))]
         [b (bytes-length basic)]
         [basic (if (zero? b) basic (bytes-append basic #"-"))]
         )
    (let loop ([n 128]
               [delta 0]
               [h b]
               [bias 72])
      ; All non-basic code points < n have been handled already. Find the next larger one:
      (let ([m (foldl (lambda (i m) (if (<= n i) (min m i) m)) maxint slist)])
        (if (= m maxint)
            basic
            ;              (o 'MN m n (+ delta (* (- m n) (+ h 1))))
            ; TODO: string-for-each
            (let small-loop ([j 0]
                             [delta (+ delta (* (- m n) (+ h 1)))]
                             [h h]
                             [bias bias])
              (if (= j (string-length str))
                  (loop (+ 1 m) (+ 1 delta) h bias)
                  (let ([c (char->integer (string-ref str j))])
                    (if (= c m)
                        (begin
                          (let loop-e ([q delta]
                                       [k 36])
                            (let ([t (min (max (- k bias) 1) 26)]) ; (bound (- k bias) tmin tmax)
                              (if (< q t)
                                  (begin
                                    (set! basic (bytes-append basic (bytes (i->b q))))
                                    (small-loop (+ 1 j) 0 (+ 1 h) (adapt delta (+ 1 h) (= h b))))
                                  (begin
                                    (set! basic (bytes-append basic (bytes (i->b (+ t (remainder (- q t) (- 36 t)))))))
                                    (loop-e (quotient (- q t) (- 36 t)) (+ 36 k)))))))
                        (small-loop (+ 1 j) (if (< c m) (+ 1 delta) delta) h bias))))))))))


; TODO: lowcase and add xn--
;; string -> bytes
(define (unicode->domain str)
  (void))

;; bytes -> string
(define (domain->unicode bstr)
  (void))

; TEST
(for-each
 (match-lambda
   [(list string punycode)
    ;(o string punycode)
    ;(o (punycode->string punycode) (string->punycode string))
    (equal! (punycode->string punycode) string)
    (equal! (string->punycode string) punycode)
    ])
 '((""                #""                  )
   ("rправда"         #"r-8sbahk7dh"       )
   ("th-จฆคฝฏขบ"      #"th--kkljln2duf1a"  )
   ("abæcdöef"        #"abcdef-qua4k"      )
   ("правда"          #"80aafi6cg"         )
   ("tūdaliņ"         #"tdali-d8a8w"       )
   ("ქართული"        #"lododh2atk"        )
   ("ελληνικά"        #"hxargifdar"        ) ; TODO: for domain, case does not matter
   ("Ελληνικά"        #"twa0c6aifdar"      )
   ("ýbücher"         #"bcher-kvaf"        )
   ("共産主義"         #"tiq01fj98b61i"     )
   ("\U10FFFF\U100000\U0FFFFF\U010000\U00FFFF" #"1n7cb032060ada88783a")
   ))


